home *** CD-ROM | disk | FTP | other *** search
/ Light ROM 1 / LIGHT-ROM 1 (Amiga Library Services)(1994).iso / ffdisks / d963.lha / SIOD / scm / esp-cont-ev.scm < prev    next >
Text File  |  1993-05-08  |  8KB  |  164 lines
  1. (define-machine explicit-control-evaluator
  2.                 (registers exp env val continue fun argl unev)
  3.                 (controller
  4.                    eval-dispatch
  5.                     (branch (self-evaluating? (fetch exp)) ev-self-eval)
  6.                     (branch (quoted? (fetch exp)) ev-quote)
  7.                     (branch (variable? (fetch? exp)) ev-variable)
  8.                     (branch (definition? (fetch exp)) ev-definition)
  9.                     (branch (assignment? (fetch exp)) ev-assignment)
  10.                     (branch (lambda? (fetch exp)) ev-cond)
  11.                     (branch (no-args? (fetch exp)) ev-no-args)
  12.                     (branch (application? (fetch exp)) ev-application)
  13.                     (goto unknown-expression-type-error)
  14.                    ev-self-eval
  15.                     (assign val (fetch exp))
  16.                     (goto (fetch continue))
  17.                    ev-quote
  18.                     (assign val (text-of-quotation (fetch exp)))
  19.                     (goto (fetch continue))
  20.                    ev-variable
  21.                     (assign val 
  22.                             (lookup-variable-value (fetch exp) (fetch env)))
  23.                     (goto (fetch continue))
  24.                    ev-lambda
  25.                     (assign val (make-procedure (fetch exp) (fetch env)))
  26.                     (goto (fetch continue))
  27.                    ev-no-args
  28.                     (assign exp (operator (fetch exp)))
  29.                     (save continue)
  30.                     (assign continue setup-no-arg-apply)
  31.                     (goto eval-dispatch)
  32.                    setup-no-arg-apply
  33.                     (assign fun (fetch val))
  34.                     (assign argl '())
  35.                     (goto apply-dispatch)
  36.                    ev-application
  37.                     (assign unev (operands (fetch exp)))
  38.                     (assign exp (operator (fetch exp)))
  39.                     (save continue)
  40.                     (save env)
  41.                     (save unev)
  42.                     (assign continue eval-args)
  43.                     (goto eval-dispatch)
  44.                    eval-args
  45.                     (restore unev)
  46.                     (restore env)
  47.                     (assign fun (fetch val))
  48.                     (save fun)
  49.                     (assign argl '())
  50.                     (goto eval-arg-loop)
  51.                    eval-arg-loop
  52.                     (save argl)
  53.                     (assign exp (first-operand (fetch unev)))
  54.                     (branch (last-operand (fetch unev)) eval-last-arg)
  55.                     (save env)
  56.                     (save unev)
  57.                     (assign continue accumulate-arg)
  58.                     (goto eval-dispatch) 
  59.                    accumulate-arg
  60.                     (restore unev)
  61.                     (restore env)
  62.                     (restore argl)
  63.                     (assign argl (cons (fetch val) (fetch argl)))
  64.                     (assign unev (rest-operands (fetch unev)))
  65.                     (goto eval-arg-loop)
  66.                    eval-last-arg
  67.                     (assign continue accumulate-last-arg)
  68.                     (goto eval-dispatch)
  69.                    accumulate-last-arg
  70.                     (restore argl)
  71.                     (assign argl (cons (fetch val) (fetch argl)))
  72.                     (restore fun)
  73.                     (goto apply-dispatch)
  74.                    apply-dispatch
  75.                     (branch (primitive-procedure? (fetch fun)) primitive-apply)
  76.                     (branch (compound-procedure? (fetch fun)) compound-apply)
  77.                     (goto unknown-procedure-type-error)
  78.                    primitive-apply
  79.                     (assign val (apply-primitive-procedure (fetch fun)
  80.                                                            (fetch argl)))
  81.                     (restore continue)
  82.                     (goto (fetch continue))
  83.                    compound-apply
  84.                     (assign env (make-binding (fetch fun) (fetch argl)))
  85.                     (assign unev (procedure-body (fetch fun)))
  86.                     (goto eval-sequence)
  87.                    eval-sequence
  88.                     (assign exp (first-exp (fetch unev)))
  89.                     (branch (last-exp? (fetch unev)) last-exp)
  90.                     (save unev)
  91.                     (save env)
  92.                     (assign continue eval-sequence-continue)
  93.                     (goto eval-dispatch) 
  94.                    eval-sequence-continue
  95.                     (restore env)
  96.                     (restore unev)
  97.                     (assign unev (rest-exps (fetch unev)))
  98.                     (goto eval-sequence)
  99.                    last-exp
  100.                     (restore continue)
  101.                     (goto eval-dispatch)
  102.                    ev-cond
  103.                     (save continue)
  104.                     (assign continue evcond-decide)
  105.                     (assign unev (clauses (fetch exp)))
  106.                    ev-cond-pred
  107.                     (branch (no-clauses? (fetch unev)) evcond-return-nil)
  108.                     (assign exp (first-clause (fetch unev)))
  109.                     (branch (else-clause? (fetch exp)) evcond-else-clause)
  110.                     (save env)
  111.                     (save unev)
  112.                     (assign exp (predicate (fetch exp)))
  113.                     (goto eval-dispatch)
  114.                    evcond-return-nil
  115.                     (restore continue)
  116.                     (assign val nil)
  117.                     (goto (fetch continue))
  118.                    evcond-decide
  119.                     (restore unev)
  120.                     (restore env)
  121.                     (branch (true? (fetch val)) evcond-true-predicate)
  122.                     (assign unev (rest-clauses (fetch unev)))
  123.                     (goto evcond-pred)
  124.                    evcond-true-predicate
  125.                     (assign exp (first-clause (fetch unev)))
  126.                    evcond-else-clause
  127.                     (assign unev (actions (fetch exp)))
  128.                     (goto eval-sequence)
  129.                    ev-assignment
  130.                     (assign unev (assignment-variable (fetch exp)))
  131.                     (save unev)
  132.                     (assign exp (assignment-value (fetch exp)))
  133.                     (save env)
  134.                     (save continue)
  135.                     (assign continue ev-assignment-1)
  136.                     (goto eval-dispatch)
  137.                    ev-definition-1
  138.                     (restore continue)
  139.                     (restore env)
  140.                     (restore unev)
  141.                     (perform
  142.                        (define-variable! (fetch unev) (fetch val) (fetch env)))
  143.                     (assign val (fetch unev))
  144.                     (goto (fetch continue))
  145.                    read-eval-print-loop 
  146.                     (perform (initialize-stack))
  147.                     (perform (newline))
  148.                     (perform (display "EC-EVAL==> "))
  149.                     (assign exp (read))
  150.                     (assign env the-global-environment)
  151.                     (assign continue print-result)
  152.                     (goto eval-dispatch)
  153.                    print-result
  154.                     (perform (user-print (fetch val)))
  155.                     (goto read-eval-print-loop)
  156.                    unknown-procedure-type-error
  157.                     (assign val 'unknown-procedure-type-error)
  158.                     (goto signal-error)
  159.                    unknown-expression-type-error
  160.                     (assign val 'unknown-expression-type-error)
  161.                     (goto signal-error)
  162.                    signal-error
  163.                     (perform (user-print (fetch val)))
  164.                     (goto read-eval-print-loop)))